home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / ddata.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  90 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Stuff moved from segment.scm  6/5/93
  5.  
  6.  
  7. ; Debug-data records are for communicating information from the
  8. ; compiler to various debugging tools.
  9.  
  10. ; Entries in an environment-maps list have the form
  11. ;   #(parent-uid pc-in-parent (env-map ...))
  12.  
  13. (define-record-type debug-data :debug-data
  14.   (make-debug-data uid name parent pc-in-parent env-maps source)
  15.   debug-data?
  16.   (uid      debug-data-uid)
  17.   (name        debug-data-name)
  18.   (parent   debug-data-parent)
  19.   (pc-in-parent debug-data-pc-in-parent)
  20.   (env-maps debug-data-env-maps set-debug-data-env-maps!)
  21.   (source   debug-data-source set-debug-data-source!))
  22.  
  23. (define (new-debug-data name parent pc-in-parent)
  24.   (make-debug-data (new-template-uid) name parent pc-in-parent '() '()))
  25.  
  26. (define-record-discloser :debug-data
  27.   (lambda (dd)
  28.     (list 'debug-data (debug-data-uid dd) (debug-data-name dd))))
  29.  
  30.  
  31. ; "Info" means either a debug data record or an integer index into a
  32. ; table of same.  An "info" is stored in a reserved place in every
  33. ; template.
  34.  
  35. (define (debug-data->info debug-data)
  36.   (make-immutable! debug-data)
  37.   (if (interesting-debug-data? debug-data)
  38.       (if (tabulate-debug-data?)
  39.       (begin (note-debug-data! debug-data)
  40.          (debug-data-uid debug-data))
  41.       debug-data)
  42.       (debug-data-uid debug-data)))    ;+++
  43.  
  44. (define (get-debug-data info)        ;info->debug-data
  45.   (cond ((debug-data? info) info)
  46.     ((integer? info)
  47.      (table-ref (debug-data-table) info))
  48.     (else #f)))
  49.  
  50. (define (note-debug-data! dd)
  51.   (table-set! (debug-data-table) (debug-data-uid dd) dd))
  52.  
  53. (define (interesting-debug-data? debug-data)
  54.   (and (debug-data? debug-data)
  55.        (or (debug-data-name debug-data)
  56.        (interesting-debug-data? (debug-data-parent debug-data))
  57.        (not (null? (debug-data-env-maps debug-data)))
  58.        (not (null? (debug-data-source debug-data))))))
  59.  
  60. ; We can follow parent links to get a full description of procedure
  61. ; nesting: "foo in bar in unnamed in baz"
  62.  
  63. (define (debug-data-names info)
  64.   (let ((dd (get-debug-data info)))
  65.     (if dd
  66.     (cons (debug-data-name dd)
  67.           (debug-data-names (debug-data-parent dd)))
  68.     '())))
  69.  
  70.  
  71. ; Associating names with templates
  72.  
  73. (define (template-debug-data tem)
  74.   (get-debug-data (template-info tem)))
  75.  
  76. (define (template-id tem)
  77.   (let ((info (template-info tem)))
  78.     (if (debug-data? info)
  79.     (debug-data-uid info)
  80.     info)))
  81.  
  82. (define (template-name tem)
  83.   (let ((probe (template-debug-data tem)))
  84.     (if probe
  85.     (debug-data-name probe)
  86.     #f)))
  87.  
  88. (define (template-names tem)
  89.   (debug-data-names (template-info tem)))
  90.